home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / tool_inc.zip / STOF.INC < prev    next >
Text File  |  1989-06-02  |  2KB  |  77 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*-----------------------------------------------------------------*)
  14. function stof(B: single): real;
  15.    {convert 4 byte single to real}
  16. var
  17.    PasReal:  real;
  18.    R: array [0..5] of byte absolute PasReal;
  19. begin
  20.    R[0] := B[3];
  21.    R[1] := 0;
  22.    R[2] := 0;
  23.    move(B[0],R[3],3);
  24.    stof := PasReal;
  25. end;
  26.  
  27.  
  28. (*-----------------------------------------------------------------*)
  29. procedure ftos(PasReal: real; var B: single);
  30.    {convert real to 4 byte single}
  31. var
  32.    R: array [0..5] of byte absolute PasReal;
  33. begin
  34.    B[3] := R[0];
  35.    move(R[3],B[0],3);
  36. end;
  37.  
  38.  
  39. (*-----------------------------------------------------------------*)
  40. function stol(s: single): longint;
  41. var
  42.    f: real;
  43. begin
  44. {writeln('stol = (',s[0]:3,s[1]:4,s[2]:4,s[3]:4,')');}
  45.  
  46.    f := int(stof(s));
  47.    if (f < -$7FFFFFFE) or (f > $7FFFFFFF) then
  48.    begin
  49.       {writeln(' f=',f:0:10);}
  50.       f := 0;
  51.    end;
  52.  
  53.    stol := trunc( f );
  54. end;
  55.  
  56.  
  57. (*-----------------------------------------------------------------*)
  58. procedure ltos(l: longint; var B: single);
  59. begin
  60.    ftos(l,B);
  61. end;
  62.  
  63.  
  64. (*-----------------------------------------------------------------*)
  65. procedure incs(var s: single; n: real);
  66. begin
  67.    ftos( trunc(stof(s)) + n, s );
  68. end;
  69.  
  70.  
  71. (*-----------------------------------------------------------------*)
  72. procedure zeros(var B: single);
  73. begin
  74.    ltos(0, B);
  75. end;
  76.  
  77.